Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/rkpls301.zip/RKPDEMO.ZIP/ENCODE.PAS

Pascal/Delphi Source File | 1993-03-04 | 4KB | 206 lines

Unit Encode;


{
  This sample unit contains example encoding algorythms for use by RkPlus.

  The encoding method used is an extremely simplistic one, but it should
  provide an idea as to how to write and implement user-written encoding
  functions.

  Warning : Do NOT use this unit in your own programmes!  Since this
            source file is available to all RkPlus users, doing so
            could compromise the security of your keys.
}


Interface


Var
  ProgID : String[36];


Function RkpOK : Boolean;
Function RkpError : Word;
Procedure SetProgID(s : String);


Implementation


Uses
  RkPlus;


Const
  vMajor    = '3';
  vMinor    = '0';
  EncConst1 : String[31] = 'Serious Cybernetics Encode Demo';
  EncConst2 : String[10] = '2163454923';
  eStatus   : Word = NoError;


Function Upper(s : String) : String;

Var
  q : Byte;

Begin
  For q := 1 to Length(s) do
    s[q] := UpCase(s[q]);
  Upper := s;
End;


{$F+}

Function UserEnc1(t1,t2,t3 : String; l : Byte; i : Integer) : Word;

Var
  ul : Char absolute l;
  ui : Array[1..2] of Char absolute i;
  s  : String;
  b1 : Byte;
  b2 : Byte;
  q  : Byte;

Begin
  UserEnc1 := 0;
  b1 := 0;
  b2 := 0;
  If (ProgID = '') then
    eStatus := InvalidParameter
  Else Begin
    s := Upper(EncConst1 + EncConst2 + ProgID + ul + ui + t3 + t2 + t1);
    For q := 1 to Length(s) do Begin
      If Odd(q) then
        b1 := b1 xor Ord(s[q])
      Else
        b2 := b2 xor Ord(s[q]);
    End;
    UserEnc1 := b1*256+b2;
  End;
End;


Function UserEnc2(t1,t2,t3 : String; l : Byte; i : Integer) : Word;

Var
  ul : Char absolute l;
  ui : Array[1..2] of Char absolute i;
  s  : String;
  b1 : Byte;
  b2 : Byte;
  q  : Byte;

Begin
  UserEnc2 := 0;
  b1 := 0;
  b2 := 0;
  If (ProgID = '') then
    eStatus := InvalidParameter
  Else Begin
    s := Upper(ui + ul + ProgID + t1 + t3 + t2 + EncConst1 + EncConst2);
    For q := 1 to Length(s) do Begin
      If Odd(q) then
        b1 := b1 xor Ord(s[q])
      Else
        b2 := b2 xor Ord(s[q]);
    End;
    UserEnc2 := b1*256+b2;
  End;
End;


Function UserEnc3(t1,t2,t3 : String; l : Byte; i : Integer) : Word;

Var
  ul : Char absolute l;
  ui : Array[1..2] of Char absolute i;
  s  : String;
  b1 : Byte;
  b2 : Byte;
  q  : Byte;

Begin
  UserEnc3 := 0;
  b1 := 0;
  b2 := 0;
  If (ProgID = '') then
    eStatus := InvalidParameter
  Else Begin
    s := Upper(t1 + t2 + t3 + ul + ProgID + EncConst1 + EncConst2 + ProgID + ui);
    For q := 1 to Length(s) do Begin
      If Odd(q) then
        b1 := b1 xor Ord(s[q])
      Else
        b2 := b2 xor Ord(s[q]);
    End;
    UserEnc3 := b1*256+b2;
  End;
End;


Function UserFileEnc(v : Byte; b : Boolean) : Byte;

Begin
  If b then
    v := v xor $01
  Else
    v := v xor $80;
  UserFileEnc := v;
End;

{$F-}


Function RkpOK : Boolean;

Begin
  RkpOK := False;
  If RkPlus.RkpOK and (eStatus = NoError) then
    RkpOK := True;
End;


Function RkpError : Word;

Begin
  If (eStatus <> NoError) then
    RkpError := eStatus
  Else
    RkpError := RkPlus.RkpError;
End;


Procedure SetProgID(s : String);

Begin
  ProgID := s;
End;


Procedure Init;

Var
  s : String[10];

Begin
  s := RkPlusVer;
  If (Length(s) < 10) or (s[8] <> vMajor) or (s[10] <> vMinor) then
    eStatus := VersionMismatch
  Else Begin
    SetEncode(UserEnc1,UserEnc2,UserEnc3);
    SetFileEnc(UserFileEnc);
  End;
  BaseYear := 1992;
  UseExpDays := False;
  ProgID := '';
End;


Begin
  Init;
End.